Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/digitr2a/control3.ctl

Text File | 1999-07-30 | 8KB | 241 lines

VERSION 5.00
Begin VB.UserControl Control3D
   Appearance      =   0  'Flat
   BackStyle       =   0  'Transparent
   CanGetFocus     =   0   'False
   ClientHeight    =   690
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   765
   ClipControls    =   0   'False
   Enabled         =   0   'False
   InvisibleAtRuntime=   -1  'True
   KeyPreview      =   -1  'True
   PropertyPages   =   "Control3D.ctx":0000
   ScaleHeight     =   690
   ScaleWidth      =   765
   ToolboxBitmap   =   "Control3D.ctx":001E
   Begin VB.Image imgIcon
      Height          =   480
      Left            =   0
      Picture         =   "Control3D.ctx":0330
      Top             =   0
      Width           =   480
   End
End
Attribute VB_Name = "Control3D"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Enum LineStyle
    Neutral
    Inward
    Outward
End Enum

Enum TagTest
    Two = -1
    None = 0
    Inset = 1
    Outset = 2
End Enum

Const VALID_CHARS = "012"

Dim NMask As String
Dim OutTag As String
Dim InTag As String
Dim Targets() As Control
Dim TargetCount As Integer
Dim NColor As Long
Dim SColor As Long
Dim HColor As Long

Dim AdjustX As Integer
Dim AdjustY As Integer

Property Get HighlightColor() As OLE_COLOR
    HighlightColor = HColor
End Property

Property Let HighlightColor(NewColor As OLE_COLOR)
    HColor = NewColor
    PropertyChanged "HighlightColor"
End Property

Property Get ShadowColor() As OLE_COLOR
    ShadowColor = SColor
End Property

Property Let ShadowColor(NewColor As OLE_COLOR)
    SColor = NewColor
    PropertyChanged "ShadowColor"
End Property

Property Get NeutralColor() As OLE_COLOR
    NeutralColor = NColor
End Property

Property Let NeutralColor(NewColor As OLE_COLOR)
    NColor = NewColor
    PropertyChanged "NeutralColor"
End Property

Property Get InsetTag() As String
Attribute InsetTag.VB_ProcData.VB_Invoke_Property = "General"
    InsetTag = InTag
End Property

Property Let InsetTag(NewTag As String)
    InTag = NewTag
    PropertyChanged "InsetTag"
End Property

Property Get OutsetTag() As String
Attribute OutsetTag.VB_ProcData.VB_Invoke_Property = "General"
    OutsetTag = OutTag
End Property

Property Let OutsetTag(NewTag As String)
    OutTag = NewTag
    PropertyChanged "OutsetTag"
End Property

Property Get NumberMask() As String
Attribute NumberMask.VB_ProcData.VB_Invoke_Property = "General"
    NumberMask = NMask
End Property

Property Let NumberMask(NewMask As String)
    NMask = CheckMask(NewMask)
    PropertyChanged "NumberMask"
End Property

Private Sub UserControl_Initialize()
    AdjustX = Screen.TwipsPerPixelX
    AdjustY = Screen.TwipsPerPixelY
End Sub

Private Sub UserControl_InitProperties()
    OutTag = "/out"
    InTag = "/in"
    SColor = vb3DShadow
    HColor = vb3DHighlight
    NColor = vb3DFace
    NMask = "11111"
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    HColor = PropBag.ReadProperty("HighlightColor", vb3DHighlight)
    SColor = PropBag.ReadProperty("ShadowColor", vb3DShadow)
    NColor = PropBag.ReadProperty("NeutralColor", vb3DFace)
    OutTag = PropBag.ReadProperty("OutsetTag", "/out")
    InTag = PropBag.ReadProperty("InsetTag", "/in")
    NMask = PropBag.ReadProperty("NumberMask", "1111")
End Sub

Private Sub UserControl_Resize()
    UserControl.Size imgIcon.Width, imgIcon.Height
End Sub

Private Sub FindTargetControls()
Dim ActiveObject, i As Integer
Dim ValidTarget As Boolean
    On Error Resume Next
    For Each ActiveObject In UserControl.Parent.Controls
        ValidTarget = False
        ValidTarget = CheckForTag(ActiveObject) > 0
        If ActiveObject.Name = Ambient.DisplayName Then ValidTarget = False
        If ValidTarget Then
            TargetCount = TargetCount + 1
            ReDim Preserve Targets(1 To TargetCount)
            Set Targets(TargetCount) = ActiveObject
        End If
    Next ActiveObject
End Sub

Public Sub PaintTargetControls()
Dim i As Integer, j As Integer
Dim LineMode As LineStyle
    FindTargetControls
    For i = 1 To Len(NMask)
        LineMode = CInt(Left(Right(NMask, i), 1))
        For j = 1 To TargetCount
            DrawLine LineMode, Targets(j), i
        Next j
    Next i
End Sub

Private Function CheckForTag(TestObj) As TagTest
Dim InsetPresent As Boolean, OutsetPresent As Boolean
    InsetPresent = InStr(1, TestObj.Tag, InTag) > 0
    OutsetPresent = InStr(1, TestObj.Tag, OutTag) > 0
    If InsetPresent Then CheckForTag = Inset
    If OutsetPresent Then CheckForTag = Outset
    If Not (InsetPresent Or OutsetPresent) Then CheckForTag = None
    If InsetPresent And OutsetPresent Then CheckForTag = Two
End Function

Public Function CheckMask(TempMask As String) As String
Dim i As Integer, CharPos As Integer
Dim Character As String, StartLen As Integer
    StartLen = Len(TempMask)
    If StartLen = 0 Then Exit Sub
    Do
        i = i + 1
        Character = Right(Left(TempMask, i), 1)
        CharPos = InStr(1, VALID_CHARS, Character)
        If Not CharPos > 0 Then
            TempMask = Left(TempMask, i - 1) & Right(TempMask, Len(TempMask) - i)
            i = i - 1
        End If
    Loop Until i = Len(TempMask)
    CheckMask = TempMask
End Function

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "HighlightColor", HColor, vb3DHighlight
    PropBag.WriteProperty "ShadowColor", SColor, vb3DShadow
    PropBag.WriteProperty "NeutralColor", NColor, vb3DFace
    PropBag.WriteProperty "OutsetTag", OutTag, "/out"
    PropBag.WriteProperty "InsetTag", InTag, "/in"
    PropBag.WriteProperty "NumberMask", NMask, "1111"
End Sub

Private Sub DrawLine(LStyle As LineStyle, ControlName As Control, Level As Integer)
Dim TopLeft As Long, BottomRight As Long, TagTest As Integer
Dim SavedScaleMode As Integer, SavedTopLeft As Long
    On Error Resume Next
    If Not ControlName.Visible Then Exit Sub
    SavedScaleMode = ControlName.Container.ScaleMode
    ControlName.Container.ScaleMode = vbTwips
    TagTest = CheckForTag(ControlName)
    If TagTest < 1 Then Exit Sub
    If LStyle = Neutral Then
        TopLeft = NColor
        BottomRight = NColor
    ElseIf LStyle = Inward Then
        TopLeft = SColor
        BottomRight = HColor
    ElseIf LStyle = Outward Then
        TopLeft = HColor
        BottomRight = SColor
    End If
    If TagTest = Inset Then
        SavedTopLeft = TopLeft
        TopLeft = BottomRight
        BottomRight = SavedTopLeft
    End If
    ControlName.Container.CurrentX = ControlName.Left - (AdjustX * Level)
    ControlName.Container.CurrentY = ControlName.Top - (AdjustY * Level)
    ControlName.Container.Line -(ControlName.Left + ControlName.Width + (AdjustX * (Level - 1)), ControlName.Top - (AdjustY * Level)), TopLeft
    ControlName.Container.Line -(ControlName.Left + ControlName.Width + (AdjustX * (Level - 1)), ControlName.Top + ControlName.Height + (AdjustY * (Level - 1))), BottomRight
    ControlName.Container.Line -(ControlName.Left - (AdjustX * Level), ControlName.Top + ControlName.Height + (AdjustY * (Level - 1))), BottomRight
    ControlName.Container.Line -(ControlName.Left - (AdjustX * Level), ControlName.Top - (AdjustY * Level)), TopLeft
    ControlName.Container.ScaleMode = SavedScaleMode
End Sub